home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / XLISP1 / !XLisp / c / XLDMEM < prev    next >
Text File  |  1990-02-24  |  12KB  |  574 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* useful definitions */
  9. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  10.  
  11. /* external variables */
  12. extern NODE ***xlstack,***xlstkbase,***xlstktop;
  13. extern NODE *obarray;
  14. extern NODE *xlenv;
  15. extern long total;
  16. extern int anodes,nnodes,nsegs,nfree,gccalls;
  17. extern struct segment *segs;
  18. extern NODE *fnodes;
  19. extern char buf[];
  20.  
  21. /* external procedures */
  22. extern char *malloc();
  23. extern char *calloc();
  24.  
  25. /* forward declarations */
  26. FORWARD NODE *newnode();
  27. FORWARD char *strsave();
  28. FORWARD char *stralloc();
  29.  
  30. /* cons - construct a new cons node */
  31. NODE *cons(x,y)
  32.   NODE *x,*y;
  33. {
  34.     NODE *val;
  35.     val = newnode(LIST);
  36.     rplaca(val,x);
  37.     rplacd(val,y);
  38.     return (val);
  39. }
  40.  
  41. /* consa - (cons x nil) */
  42. NODE *consa(x)
  43.   NODE *x;
  44. {
  45.     NODE *val;
  46.     val = newnode(LIST);
  47.     rplaca(val,x);
  48.     return (val);
  49. }
  50.  
  51. /* consd - (cons nil x) */
  52. NODE *consd(x)
  53.   NODE *x;
  54. {
  55.     NODE *val;
  56.     val = newnode(LIST);
  57.     rplacd(val,x);
  58.     return (val);
  59. }
  60.  
  61. /* cvstring - convert a string to a string node */
  62. NODE *cvstring(str)
  63.   char *str;
  64. {
  65.     NODE ***oldstk,*val;
  66.     oldstk = xlsave(&val,(NODE **)NULL);
  67.     val = newnode(STR);
  68.     val->n_str = strsave(str);
  69.     val->n_strtype = DYNAMIC;
  70.     xlstack = oldstk;
  71.     return (val);
  72. }
  73.  
  74. /* cvcstring - convert a constant string to a string node */
  75. NODE *cvcstring(str)
  76.   char *str;
  77. {
  78.     NODE *val;
  79.     val = newnode(STR);
  80.     val->n_str = str;
  81.     val->n_strtype = STATIC;
  82.     return (val);
  83. }
  84.  
  85. /* cvsymbol - convert a string to a symbol */
  86. NODE *cvsymbol(pname)
  87.   char *pname;
  88. {
  89.     NODE ***oldstk,*val;
  90.     oldstk = xlsave(&val,(NODE **)NULL);
  91.     val = newnode(SYM);
  92.     val->n_symplist = newnode(LIST);
  93.     rplaca(val->n_symplist,cvstring(pname));
  94.     xlstack = oldstk;
  95.     return (val);
  96. }
  97.  
  98. /* cvcsymbol - convert a constant string to a symbol */
  99. NODE *cvcsymbol(pname)
  100.   char *pname;
  101. {
  102.     NODE ***oldstk,*val;
  103.     oldstk = xlsave(&val,(NODE **)NULL);
  104.     val = newnode(SYM);
  105.     val->n_symplist = newnode(LIST);
  106.     rplaca(val->n_symplist,cvcstring(pname));
  107.     xlstack = oldstk;
  108.     return (val);
  109. }
  110.  
  111. /* cvsubr - convert a function to a subr or fsubr */
  112. NODE *cvsubr(fcn,type)
  113.   NODE *(*fcn)(); int type;
  114. {
  115.     NODE *val;
  116.     val = newnode(type);
  117.     val->n_subr = fcn;
  118.     return (val);
  119. }
  120.  
  121. /* cvfile - convert a file pointer to a file */
  122. NODE *cvfile(fp)
  123.   FILE *fp;
  124. {
  125.     NODE *val;
  126.     val = newnode(FPTR);
  127.     setfile(val,fp);
  128.     setsavech(val,0);
  129.     return (val);
  130. }
  131.  
  132. /* cvfixnum - convert an integer to a fixnum node */
  133. NODE *cvfixnum(n)
  134.   FIXNUM n;
  135. {
  136.     NODE *val;
  137.     val = newnode(INT);
  138.     val->n_int = n;
  139.     return (val);
  140. }
  141.  
  142. /* cvflonum - convert a floating point number to a flonum node */
  143. NODE *cvflonum(n)
  144.   FLONUM n;
  145. {
  146.     NODE *val;
  147.     val = newnode(FLOAT);
  148.     val->n_float = n;
  149.     return (val);
  150. }
  151.  
  152. /* newstring - allocate and initialize a new string */
  153. NODE *newstring(size)
  154.   int size;
  155. {
  156.     NODE ***oldstk,*val;
  157.     oldstk = xlsave(&val,(NODE **)NULL);
  158.     val = newnode(STR);
  159.     val->n_str = stralloc(size);
  160.     *getstring(val) = 0;
  161.     val->n_strtype = DYNAMIC;
  162.     xlstack = oldstk;
  163.     return (val);
  164. }
  165.  
  166. /* newobject - allocate and initialize a new object */
  167. NODE *newobject(cls,size)
  168.   NODE *cls; int size;
  169. {
  170.     NODE *val;
  171.     val = newvector(size+1);
  172.     setelement(val,0,cls);
  173.     val->n_type = OBJ;
  174.     return (val);
  175. }
  176.  
  177. /* newvector - allocate and initialize a new vector node */
  178. NODE *newvector(size)
  179.   int size;
  180. {
  181.     NODE ***oldstk,*vect;
  182.     int bsize;
  183.  
  184.     /* establish a new stack frame */
  185.     oldstk = xlsave(&vect,(NODE **)NULL);
  186.  
  187.     /* allocate a vector node and set the size to zero (in case of gc) */
  188.     vect = newnode(VECT);
  189.     vect->n_vsize = 0;
  190.  
  191.     /* allocate memory for the vector */
  192.     bsize = size * sizeof(NODE *);
  193. #ifdef Risc
  194.     /* The calloc supplied with Acorn C does not like being asked for an
  195.        object of zero bytes so fake it. */       
  196.     if (bsize == 0) bsize = 1;
  197. #endif
  198.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
  199.     findmem();
  200.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
  201.         xlfail("insufficient vector space");
  202.     }
  203.     vect->n_vsize = size;
  204.     total += (long) bsize;
  205.  
  206.     /* restore the previous stack frame */
  207.     xlstack = oldstk;
  208.  
  209.     /* return the new vector */
  210.     return (vect);
  211. }
  212.  
  213. /* newnode - allocate a new node */
  214. LOCAL NODE *newnode(type)
  215.   int type;
  216. {
  217.     NODE *nnode;
  218.  
  219.     /* get a free node */
  220.     if ((nnode = fnodes) == NIL) {
  221.     findmem();
  222.     if ((nnode = fnodes) == NIL)
  223.         xlabort("insufficient node space");
  224.     }
  225.  
  226.     /* unlink the node from the free list */
  227.     fnodes = cdr(nnode);
  228.     nfree -= 1;
  229.  
  230.     /* initialize the new node */
  231.     nnode->n_type = type;
  232.     rplacd(nnode,NIL);
  233.  
  234.     /* return the new node */
  235.     return (nnode);
  236. }
  237.  
  238. /* stralloc - allocate memory for a string adding a byte for the terminator */
  239. LOCAL char *stralloc(size)
  240.   int size;
  241. {
  242.     char *sptr;
  243.  
  244.     /* allocate memory for the string copy */
  245.     if ((sptr = malloc(size+1)) == NULL) {
  246.     findmem();
  247.     if ((sptr = malloc(size+1)) == NULL)
  248.         xlfail("insufficient string space");
  249.     }
  250.     total += (long) (size+1);
  251.  
  252.     /* return the new string memory */
  253.     return (sptr);
  254. }
  255.  
  256. /* strsave - generate a dynamic copy of a string */
  257. LOCAL char *strsave(str)
  258.   char *str;
  259. {
  260.     char *sptr;
  261.  
  262.     /* create a new string */
  263.     sptr = stralloc(strlen(str));
  264.     strcpy(sptr,str);
  265.  
  266.     /* return the new string */
  267.     return (sptr);
  268. }
  269.  
  270. /* strfree - free a string                 UNUSED
  271. LOCAL strfree(str)
  272.   char *str;
  273. {
  274.     total -= (long) (strlen(str)+1);
  275.     free(str);
  276. }
  277. */
  278.  
  279. /* findmem - find more memory by collecting then expanding */
  280. findmem()
  281. {
  282.     gc();
  283.     if (nfree < anodes)
  284.     addseg();
  285. }
  286.  
  287. /* gc - garbage collect */
  288. gc()
  289. {
  290.     NODE ***p;
  291.     void mark();
  292.  
  293.     /* mark the obarray and the current environment */
  294.     mark(obarray);
  295.     mark(xlenv);
  296.  
  297.     /* mark the evaluation stack */
  298.     for (p = xlstack; p < xlstktop; )
  299.     mark(**p++);
  300.  
  301.     /* sweep memory collecting all unmarked nodes */
  302.     sweep();
  303.  
  304.     /* count the gc call */
  305.     gccalls++;
  306. }
  307.  
  308. /* mark - mark all accessible nodes */
  309. void mark(ptr)
  310.   NODE *ptr;
  311. {
  312.     NODE *this,*prev,*tmp;
  313.  
  314.     /* just return on nil */
  315.     if (ptr == NIL)
  316.     return;
  317.  
  318.     /* initialize */
  319.     prev = NIL;
  320.     this = ptr;
  321.  
  322.     /* mark this list */
  323.     while (TRUE) {
  324.  
  325.     /* descend as far as we can */
  326.     while (TRUE) {
  327.  
  328.         /* check for this node being marked */
  329.         if (this->n_flags & MARK)
  330.         break;
  331.  
  332.         /* mark it and its descendants */
  333.         else {
  334.  
  335.         /* mark the node */
  336.         this->n_flags |= MARK;
  337.  
  338.         /* follow the left sublist if there is one */
  339.         if (livecar(this)) {
  340.             this->n_flags |= LEFT;
  341.             tmp = prev;
  342.             prev = this;
  343.             this = car(prev);
  344.             rplaca(prev,tmp);
  345.         }
  346.  
  347.         /* otherwise, follow the right sublist if there is one */
  348.         else if (livecdr(this)) {
  349.             this->n_flags &= ~LEFT;
  350.             tmp = prev;
  351.             prev = this;
  352.             this = cdr(prev);
  353.             rplacd(prev,tmp);
  354.         }
  355.         else
  356.             break;
  357.         }
  358.     }
  359.  
  360.     /* backup to a point where we can continue descending */
  361.     while (TRUE) {
  362.  
  363.         /* check for termination condition */
  364.         if (prev == NIL)
  365.         return;
  366.  
  367.         /* check for coming from the left side */
  368.         if (prev->n_flags & LEFT)
  369.         if (livecdr(prev)) {
  370.             prev->n_flags &= ~LEFT;
  371.             tmp = car(prev);
  372.             rplaca(prev,this);
  373.             this = cdr(prev);
  374.             rplacd(prev,tmp);
  375.             break;
  376.         }
  377.         else {
  378.             tmp = prev;
  379.             prev = car(tmp);
  380.             rplaca(tmp,this);
  381.             this = tmp;
  382.         }
  383.  
  384.         /* otherwise, came from the right side */
  385.         else {
  386.         tmp = prev;
  387.         prev = cdr(tmp);
  388.         rplacd(tmp,this);
  389.         this = tmp;
  390.         }
  391.     }
  392.     }
  393. }
  394.  
  395. /* vmark - mark a vector */
  396. vmark(n)
  397.   NODE *n;
  398. {
  399.     int i;
  400.     for (i = 0; i < getsize(n); ++i)
  401.     mark(getelement(n,i));
  402. }
  403.  
  404. /* sweep - sweep all unmarked nodes and add them to the free list */
  405. LOCAL sweep()
  406. {
  407.     struct segment *seg;
  408.     NODE *p;
  409.     int n;
  410.  
  411.     /* empty the free list */
  412.     fnodes = NIL;
  413.     nfree = 0;
  414.  
  415.     /* add all unmarked nodes */
  416.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  417.     p = &seg->sg_nodes[0];
  418.     for (n = seg->sg_size; n--; p++)
  419.         if (!(p->n_flags & MARK)) {
  420.         switch (ntype(p)) {
  421.         case STR:
  422.             if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
  423.                 total -= (long) (strlen(p->n_str)+1);
  424.                 free(p->n_str);
  425.             }
  426.             break;
  427.         case FPTR:
  428.             if (p->n_fp)
  429.                 fclose(p->n_fp);
  430.             break;
  431.         case VECT:
  432.             if (p->n_vsize) {
  433.                 total -= (long) (p->n_vsize * sizeof(NODE **));
  434.                 free(p->n_vdata);
  435.             }
  436.             break;
  437.         }
  438.         p->n_type = FREE;
  439.         p->n_flags = 0;
  440.         rplaca(p,NIL);
  441.         rplacd(p,fnodes);
  442.         fnodes = p;
  443.         nfree++;
  444.         }
  445.         else
  446.         p->n_flags &= ~(MARK | LEFT);
  447.     }
  448. }
  449.  
  450. /* addseg - add a segment to the available memory */
  451. int addseg()
  452. {
  453.     struct segment *newseg;
  454.     NODE *p;
  455.     int n;
  456.  
  457.     /* check for zero allocation */
  458.     if (anodes == 0)
  459.     return (FALSE);
  460.  
  461.     /* allocate a new segment */
  462.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  463.  
  464.     /* initialize the new segment */
  465.     newseg->sg_size = anodes;
  466.     newseg->sg_next = segs;
  467.     segs = newseg;
  468.  
  469.     /* add each new node to the free list */
  470.     p = &newseg->sg_nodes[0];
  471.     for (n = anodes; n--; ) {
  472.         rplacd(p,fnodes);
  473.         fnodes = p++;
  474.     }
  475.  
  476.     /* update the statistics */
  477.     total += (long) ALLOCSIZE;
  478.     nnodes += anodes;
  479.     nfree += anodes;
  480.     nsegs++;
  481.  
  482.     /* return successfully */
  483.     return (TRUE);
  484.     }
  485.     else
  486.     return (FALSE);
  487. }
  488.  
  489. /* livecar - do we need to follow the car? */
  490. LOCAL int livecar(n)
  491.   NODE *n;
  492. {
  493.     switch (ntype(n)) {
  494.     case OBJ:
  495.     case VECT:
  496.         vmark(n);
  497.     case SUBR:
  498.     case FSUBR:
  499.     case INT:
  500.     case FLOAT:
  501.     case STR:
  502.     case FPTR:
  503.         return (FALSE);
  504.     case SYM:
  505.     case LIST:
  506.         return (car(n) != NIL);
  507.     default:
  508.         printf("bad node type (%d) found during left scan\n",ntype(n));
  509.         osfinish ();
  510.         exit(1);
  511.     }
  512.     /*NOTREACHED*/
  513. }
  514.  
  515. /* livecdr - do we need to follow the cdr? */
  516. LOCAL int livecdr(n)
  517.   NODE *n;
  518. {
  519.     switch (ntype(n)) {
  520.     case SUBR:
  521.     case FSUBR:
  522.     case INT:
  523.     case FLOAT:
  524.     case STR:
  525.     case FPTR:
  526.     case OBJ:
  527.     case VECT:
  528.         return (FALSE);
  529.     case SYM:
  530.     case LIST:
  531.         return (cdr(n) != NIL);
  532.     default:
  533.         printf("bad node type (%d) found during right scan\n",ntype(n));
  534.         osfinish ();
  535.         exit(1);
  536.     }
  537.     /*NOTREACHED*/
  538. }
  539.  
  540. /* stats - print memory statistics */
  541. stats()
  542. {
  543.     sprintf(buf,"Nodes:       %d\n",nnodes);  stdputstr(buf);
  544.     sprintf(buf,"Free nodes:  %d\n",nfree);   stdputstr(buf);
  545.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  546.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  547.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  548.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  549. }
  550.  
  551. /* xlminit - initialize the dynamic memory module */
  552. xlminit()
  553. {
  554.     /* initialize our internal variables */
  555.     anodes = NNODES;
  556.     total = 0L;
  557.     nnodes = nsegs = nfree = gccalls = 0;
  558.     fnodes = NIL;
  559.     segs = NULL;
  560.  
  561.     /* initialize structures that are marked by the collector */
  562.     xlenv = obarray = NIL;
  563.  
  564.     /* allocate the evaluation stack */
  565.     if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
  566.     printf("insufficient memory");
  567.     osfinish ();
  568.     exit(1);
  569.     }
  570.     total += (long)(EDEPTH * sizeof(NODE **));
  571.     xlstack = xlstktop = xlstkbase + EDEPTH;
  572. }
  573.  
  574.